home *** CD-ROM | disk | FTP | other *** search
/ Dr. Windows 3 / dr win3.zip / dr win3 / UTILITY1 / MSWSRC35.ZIP / LISTS.CPP < prev    next >
C/C++ Source or Header  |  1993-08-19  |  15KB  |  715 lines
  1. /*
  2.  *      lists.c         logo list functions module              dvb
  3.  *
  4.  *    Copyright (C) 1989 The Regents of the University of California
  5.  *    This Software may be copied and distributed for educational,
  6.  *    research, and not for profit purposes provided that this
  7.  *    copyright and statement are included in all such copies.
  8.  */
  9.  
  10. #include "logo.h"
  11. #include "globals.h"
  12.  
  13. typedef char *(*kludge_type)(char *, char *, int);
  14.  
  15. NODE *bfable_arg(NODE *args)
  16. {
  17.     NODE *arg = car(args);
  18.  
  19.     while ((arg == NIL || arg == UNBOUND || arg == Null_Word ||
  20.         nodetype(arg) == ARRAY) && NOT_THROWING) {
  21.     setcar(args, err_logo(BAD_DATA, arg));
  22.     arg = car(args);
  23.     }
  24.     return arg;
  25. }
  26.  
  27. NODE *list_arg(NODE *args)
  28. {
  29.     NODE *arg = car(args);
  30.  
  31.     while (!(arg == NIL || is_list(arg)) && NOT_THROWING) {
  32.     setcar(args, err_logo(BAD_DATA, arg));
  33.     arg = car(args);
  34.     }
  35.     return arg;
  36. }
  37.  
  38. NODE *lbutfirst(NODE *args)
  39. {
  40.     NODE *val = UNBOUND, *arg;
  41.  
  42.     arg = bfable_arg(args);
  43.     if (NOT_THROWING) {
  44.     if (is_list(arg))
  45.         val = cdr(arg);
  46.     else {
  47.         setcar(args, cnv_node_to_strnode(arg));
  48.         arg = car(args);
  49.         if (getstrlen(arg) > 1)
  50.         val = make_strnode(getstrptr(arg) + 1,
  51.               getstrhead(arg),
  52.               getstrlen(arg) - 1,
  53.               nodetype(arg),
  54.               strnzcpy);
  55.         else
  56.         val = Null_Word;
  57.     }
  58.     }
  59.     return(val);
  60. }
  61.  
  62. NODE *lbutlast(NODE *args)
  63. {
  64.     NODE *val = UNBOUND, *lastnode, *tnode, *arg;
  65.  
  66.     arg = bfable_arg(args);
  67.     if (NOT_THROWING) {
  68.     if (is_list(arg)) {
  69.         args = arg;
  70.         val = NIL;
  71.         while (cdr(args) != NIL) {
  72.         tnode = cons(car(args), NIL);
  73.         if (val == NIL) {
  74.             val = tnode;
  75.             lastnode = tnode;
  76.         } else {
  77.             setcdr(lastnode, tnode);
  78.             lastnode = tnode;
  79.         }
  80.         args = cdr(args);
  81.         if (check_throwing) break;
  82.         }
  83.     } else {
  84.         setcar(args, cnv_node_to_strnode(arg));
  85.         arg = car(args);
  86.         if (getstrlen(arg) > 1)
  87.         val = make_strnode(getstrptr(arg),
  88.               getstrhead(arg),
  89.               getstrlen(arg) - 1,
  90.               nodetype(arg),
  91.               strnzcpy);
  92.         else
  93.         val = Null_Word;
  94.     }
  95.     }
  96.     return(val);
  97. }
  98.  
  99. NODE *lfirst(NODE *args)
  100. {
  101.     NODE *val = UNBOUND, *arg;
  102.  
  103.     if (nodetype(car(args)) == ARRAY) {
  104.     return make_intnode((FIXNUM)getarrorg(car(args)));
  105.     }
  106.     arg = bfable_arg(args);
  107.     if (NOT_THROWING) {
  108.     if (is_list(arg))
  109.         val = car(arg);
  110.     else {
  111.         setcar(args, cnv_node_to_strnode(arg));
  112.         arg = car(args);
  113.         val = make_strnode(getstrptr(arg), getstrhead(arg), 1,
  114.                    nodetype(arg), strnzcpy);
  115.     }
  116.     }
  117.     return(val);
  118. }
  119.  
  120. NODE *lfirsts(NODE *args)
  121. {
  122.     NODE *val = UNBOUND, *arg, *argp, *tail;
  123.  
  124.     arg = list_arg(args);
  125.     if (car(args) == NIL) return(NIL);
  126.     if (NOT_THROWING) {
  127.     val = cons(lfirst(arg), NIL);
  128.     tail = val;
  129.     for (argp = cdr(arg); argp != NIL; argp = cdr(argp)) {
  130.         setcdr(tail, cons(lfirst(argp), NIL));
  131.         tail = cdr(tail);
  132.         if (check_throwing) break;
  133.     }
  134.     if (stopping_flag == THROWING) {
  135.         gcref(val);
  136.         return UNBOUND;
  137.     }
  138.     }
  139.     return(val);
  140. }
  141.  
  142. NODE *lbfs(NODE *args)
  143. {
  144.     NODE *val = UNBOUND, *arg, *argp, *tail;
  145.  
  146.     arg = list_arg(args);
  147.     if (car(args) == NIL) return(NIL);
  148.     if (NOT_THROWING) {
  149.     val = cons(lbutfirst(arg), NIL);
  150.     tail = vref(val);
  151.     for (argp = cdr(arg); argp != NIL; argp = cdr(argp)) {
  152.         setcdr(tail, cons(lbutfirst(argp), NIL));
  153.         tail = cdr(tail);
  154.         if (check_throwing) break;
  155.     }
  156.     if (stopping_flag == THROWING) {
  157.         gcref(val);
  158.         return UNBOUND;
  159.     }
  160.     }
  161.     return(val);
  162. }
  163.  
  164. NODE *llast(NODE *args)
  165. {
  166.     NODE *val = UNBOUND, *arg;
  167.  
  168.     arg = bfable_arg(args);
  169.     if (NOT_THROWING) {
  170.     if (is_list(arg)) {
  171.         args = arg;
  172.         while (cdr(args) != NIL) {
  173.         args = cdr(args);
  174.         if (check_throwing) break;
  175.         }
  176.         val = car(args);
  177.     }
  178.     else {
  179.         setcar(args, cnv_node_to_strnode(arg));
  180.         arg = car(args);
  181.         val = make_strnode(getstrptr(arg) + getstrlen(arg) - 1,
  182.                    getstrhead(arg), 1, nodetype(arg), strnzcpy);
  183.     }
  184.     }
  185.     return(val);
  186. }
  187.  
  188. NODE *llist(NODE *args)
  189. {
  190.     return(args);
  191. }
  192.  
  193. NODE *lemptyp(NODE *arg)
  194. {
  195.     return torf(car(arg) == NIL || car(arg) == Null_Word);
  196. }
  197.  
  198. NODE *char_arg(NODE *args)
  199. {
  200.     NODE *arg = car(args), *val;
  201.  
  202.     val = cnv_node_to_strnode(arg);
  203.     while ((val == UNBOUND || getstrlen(val) != 1) && NOT_THROWING) {
  204.     gcref(val);
  205.     setcar(args, err_logo(BAD_DATA, arg));
  206.     arg = car(args);
  207.     val = cnv_node_to_strnode(arg);
  208.     }
  209.     setcar(args,val);
  210.     return(val);
  211. }
  212.  
  213. NODE *lascii(NODE *args)
  214. {
  215.     FIXNUM i;
  216.     NODE *val = UNBOUND, *arg;
  217.  
  218.     arg = char_arg(args);
  219.     if (NOT_THROWING) {
  220.     i = (FIXNUM)clearparity(*getstrptr(arg)) & 0377;
  221.     val = make_intnode(i);
  222.     }
  223.     return(val);
  224. }
  225.  
  226. NODE *lbackslashedp(NODE *args)
  227. {
  228.     char i;
  229.     NODE *arg;
  230.  
  231.     arg = char_arg(args);
  232.     if (NOT_THROWING) {
  233.     i = *getstrptr(arg);
  234.     return torf(getparity(i));
  235.     }
  236.     return(UNBOUND);
  237. }
  238.  
  239. NODE *lchar(NODE *args)
  240. {
  241.     NODE *val = UNBOUND, *arg;
  242.     char c;
  243.  
  244.     arg = pos_int_arg(args);
  245.     if (NOT_THROWING) {
  246.     c = getint(arg);
  247.     val = make_strnode(&c, (char *)NULL, 1,
  248.                (getparity(c) ? STRING : BACKSLASH_STRING), strnzcpy);
  249.     }
  250.     return(val);
  251. }
  252.  
  253. NODE *lcount(NODE *args)
  254. {
  255.     int cnt = 0;
  256.     NODE *arg;
  257.  
  258.     arg = car(args);
  259.     if (arg != NIL && arg != Null_Word) {
  260.     if (is_list(arg)) {
  261.         args = arg;
  262.         for (; args != NIL; cnt++) {
  263.         args = cdr(args);
  264.         if (check_throwing) break;
  265.         }
  266.     } else if (nodetype(arg) == ARRAY) {
  267.         cnt = getarrdim(arg);
  268.     } else {
  269.         setcar(args, cnv_node_to_strnode(arg));
  270.         cnt = getstrlen(car(args));
  271.     }
  272.     }
  273.     return(make_intnode((FIXNUM)cnt));
  274. }
  275.  
  276. NODE *lfput(NODE *args)
  277. {
  278.     NODE *lst, *arg;
  279.  
  280.     arg = car(args);
  281.     lst = list_arg(cdr(args));
  282.     if (NOT_THROWING)
  283.     return cons(arg,lst);
  284.     else
  285.     return UNBOUND;
  286. }
  287.  
  288. NODE *llput(NODE *args)
  289. {
  290.     NODE *lst, *arg, *val = UNBOUND, *lastnode = NIL, *tnode = NIL;
  291.  
  292.     arg = car(args);
  293.     lst = list_arg(cdr(args));
  294.     if (NOT_THROWING) {
  295.     val = NIL;
  296.     while (lst != NIL) {
  297.         tnode = cons(car(lst), NIL);
  298.         if (val == NIL) {
  299.         val = tnode;
  300.         } else {
  301.         setcdr(lastnode, tnode);
  302.         }
  303.         lastnode = tnode;
  304.         lst = cdr(lst);
  305.         if (check_throwing) break;
  306.     }
  307.     if (val == NIL)
  308.         val = cons(arg, NIL);
  309.     else
  310.         setcdr(lastnode, cons(arg, NIL));
  311.     }
  312.     return(val);
  313. }
  314.  
  315. NODE *string_arg(NODE *args)
  316. {
  317.     NODE *arg = car(args), *val;
  318.  
  319.     val = cnv_node_to_strnode(arg);
  320.     while (val == UNBOUND && NOT_THROWING) {
  321.     gcref(val);
  322.     setcar(args, err_logo(BAD_DATA, arg));
  323.     arg = car(args);
  324.     val = cnv_node_to_strnode(arg);
  325.     }
  326.     setcar(args,val);
  327.     return(val);
  328. }
  329.  
  330. NODE *lword(NODE *args)
  331. {
  332.     NODE *val = NIL, *arg = NIL;
  333. //    NODE *tnode = NIL;
  334. //    NODE *lastnode = NIL;
  335.     int cnt = 0;
  336.     NODETYPES str_type = STRING;
  337.  
  338.     if (args == NIL) return Null_Word;
  339.     val = args;
  340.     while (val != NIL && NOT_THROWING) {
  341.     arg = string_arg(val);
  342.     val = cdr(val);
  343.     if (NOT_THROWING) {
  344.         if (backslashed(arg))
  345.         str_type = VBAR_STRING;
  346.         cnt += getstrlen(arg);
  347.     }
  348.     }
  349.     if (NOT_THROWING)
  350.     val = make_strnode((char *)args, (char *)NULL,
  351.                cnt, str_type, (kludge_type)word_strnzcpy); /* kludge */
  352.     else
  353.     val = UNBOUND;
  354.     return(val);
  355. }
  356.  
  357. NODE *lsentence(NODE *args)
  358. {
  359.     NODE *tnode = NIL, *lastnode = NIL, *val = NIL, *arg = NIL;
  360.  
  361.     while (args != NIL && NOT_THROWING) {
  362.     arg = car(args);
  363.     while (nodetype(arg) == ARRAY && NOT_THROWING) {
  364.         setcar(args, err_logo(BAD_DATA, arg));
  365.         arg = car(args);
  366.     }
  367.     args = cdr(args);
  368.     if (stopping_flag == THROWING) break;
  369.     if (is_list(arg)) {
  370.         while (arg != NIL && NOT_THROWING) {
  371.         tnode = cons(car(arg), NIL);
  372.         arg = cdr(arg);
  373.         if (val == NIL) val = tnode;
  374.         else setcdr(lastnode, tnode);
  375.         lastnode = tnode;
  376.         }
  377.     } else {
  378.         tnode = cons(arg, NIL);
  379.         if (val == NIL) val = tnode;
  380.         else setcdr(lastnode, tnode);
  381.         lastnode = tnode;
  382.     }
  383.     }
  384.     if (stopping_flag == THROWING) {
  385.     gcref(v